(defun simplify (a) 
   (if (atom a) 
       a 
       (destructuring-bind (op x y) a 
        (let* ((f (simplify x)) 
               (g (simplify y)) 
               (nf (numberp f)) 
               (ng (numberp g)) 
               (+? (eq '+ op)) 
               (*? (eq '* op))) 
          (cond 
            ((and +? nf ng)                   (+ f g)) 
            ((and +? nf (zerop f))            g) 
            ((and +? ng (zerop g))            f) 
            ((and (listp g) (eq op (first g))) 
             (destructuring-bind (op2 u v) g 
               (simplify `(,op (,op ,f ,u) ,v)))) 
            ((and *? nf ng)                   (* f g)) 
            ((and *? (or (and nf (zerop f)) 
                         (and ng (zerop g)))) 0) 
            ((and *? nf (= 1 f))              g) 
            ((and *? ng (= 1 g))              f) 
            (t                                `(,op ,f ,g))))))) 

(defun tt (N) (gc) (time (test N)))

(setq *expr* '(* X (+ (+ (* 12 0) (+ 23 8)) Y)))

(defun test (N)
   (COND ((ZEROP N) 0)
         (T (simplify *expr*) (test (1- N)))))
  
(mapc 'compile '(tt test simplify))



